C----------------------------------------------------------------------------

C  Module name: phigslib.

C  Author: Toby Howard.

C  Function: This module contains a collection of
C            useful routines, built on top of KRT3.
C            See document KRT3/57 for detailed specs.

C  Hashtables used: "structureid".

C  Modification history: (Version), (Date), (name), (Description).

C  1.0, ?????, T. Howard, First version.

C  1.1, 15th July 1988, S. Larkin, Modified to work with VAX PHIGS.

C  1.2, 24th August 1988, S. Larkin, Procedure ptk_drawcolourtable added.

C  2.0, 8th January 1991, G. Williams, Converted from Pascal to C. removed
C  obsolete functions.

C  2.1, 15th February 1991, G. Williams, Function ptk_findelemtype added.

C  2.2, 2nd May 1991, G. Williams, Bundled attribute functions added:
C  ptk_setattrasf, ptk_setallattrasf, ptk_setedgebundlerec,
C  ptk_setinteriorbundlerec, ptk_setpolylinebundlerec,
C  ptk_setpolymarkerbundlerec, ptk_settextbundlerec.

C----------------------------------------------------------------------------

       INTEGER FUNCTION ptkf_readint(ws, defint, prompt, echoarea)
C /*
C ** \parambegin
C ** \param{INTEGER}{ws}{workstation identifier}{IN}
C ** \param{INTEGER}{defint}{default integer}{IN}
C ** \param{CHARACTER*(*)}{prompt}{prompt string}{IN}
C ** \param{REAL}{echoarea(4)}{string echo area}{IN}
C ** \paramend
C ** \blurb{This function reads and returns  an integer from 
C ** string device 1 on workstation \pardesc{ws},
C ** using \pardesc{prompt} as a prompt string.
C ** If the user types a carriage-return instead of supplying an
C ** integer, the function returns the specified default value 
C ** \pardesc{defint}.
C ** \pardesc{echoarea} specifies the echo area to use for the string device.}
C */
       INTEGER ws, defint
       CHARACTER*(*) prompt
       REAL echoarea(4)
       INTEGER ptk_readint
       external ptk_readint !$PRAGMA C(ptk_readint)

       ptkf_readint = ptk_readint(%val(ws), %val(defint), prompt, 
& echoarea)

       RETURN
       END

       REAL FUNCTION ptkf_readfloat(ws, defreal, prompt, echoarea)
C /*
C ** \parambegin
C ** \param{INTEGER}{ws}{workstation identifier}{IN}
C ** \param{REAL}{defreal}{default floating point number}{IN}
C ** \param{CHARACTER*(*)}{prompt}{prompt string}{IN}
C ** \param{REAL}{echoarea(4)}{string echo area}{IN}
C ** \paramend
C ** \blurb{This function reads and returns a real number from 
C ** string device 1 on workstation \pardesc{ws},
C ** using \pardesc{prompt} as a prompt string.
C ** If the user types a carriage-return instead of supplying an
C ** real value, the function returns the specified default value 
C ** \pardesc{defreal}.
C ** \pardesc{echoarea} specifies the echo area to use for the string device.}
C */
       INTEGER ws
       REAL defreal
       CHARACTER*(*) prompt
       REAL echoarea(4)
       REAL*8 dpdefreal
       REAL ptkc_readfloat
       external ptkc_readfloat !$PRAGMA C(ptkc_readfloat)

       dpdefreal = defreal
       ptkf_readfloat = ptkc_readfloat(%val(ws), %val(dpdefreal), 
& prompt, echoarea)

       RETURN
       END

       SUBROUTINE ptkf_readstring(ws, defstring, prompt, echoarea, len, 
& instr, inlen)
C /*
C ** \parambegin
C ** \param{INTEGER}{ws}{workstation identifier}{IN}
C ** \param{CHARACTER*(*)}{defstring}{default string}{IN}
C ** \param{CHARACTER*(*)}{prompt}{prompt string}{IN}
C ** \param{REAL}{echoarea(4)}{string echo area}{IN}
C ** \param{INTEGER}{len}{number of characters allocated for input string}{IN}
C ** \param{CHARACTER*(*)}{instr}{input string}{OUT}
C ** \param{INTEGER}{inlen}{length of input string}{OUT}
C ** \paramend
C ** \blurb{This function reads and returns a real number from 
C ** string device 1 on workstation \pardesc{ws},
C ** using \pardesc{prompt} as a prompt string.
C ** If the user types a carriage-return instead of supplying a
C ** string, the function returns the specified default value 
C ** \pardesc{defstring}.
C ** \pardesc{echoarea} specifies the echo area to use for the string device.}
C */
       INTEGER ws
       CHARACTER*(*) defstring, prompt
       REAL echoarea(4)
       INTEGER len
       CHARACTER*(*) instr
       INTEGER inlen
       external ptk_readstring !$PRAGMA C(ptk_readstring)

       call ptk_readstring(%val(ws), defstring, prompt, echoarea,
& %val(len), instr, inlen)

       RETURN
       END

       SUBROUTINE ptkf_stackstruct()
C /*
C ** \blurb{This function stores the name
C **  of the currently open structure and the position of the element
C **  pointer on the structure stack, and closes the structure.}
C */
       external ptk_stackstruct !$PRAGMA C(ptk_stackstruct)

       call ptk_stackstruct()

       RETURN
       END

       SUBROUTINE ptkf_unstackstruct()
C /*
C ** \blurb{This function pops the structure stack,
C **  opens the structure and sets the element pointer.}
C */
       external ptk_unstackstruct !$PRAGMA C(ptk_unstackstruct)

       call ptk_unstackstruct()

       RETURN
       END

       SUBROUTINE ptkf_openstruct(structid)
C /*
C ** \parambegin
C ** \param{INTEGER}{structid}{structure identifier}{IN}
C ** \paramend
C ** \blurb{This function stores the currently open structure and
C **  element pointer on
C ** a stack and opens the structure {\tt structid}.}
C */
       INTEGER structid
       external ptk_openstruct !$PRAGMA C(ptk_openstruct)

       call ptk_openstruct(%val(structid))

       RETURN
       END

       SUBROUTINE ptkf_closestruct()
C /*
C ** \blurb{This function closes the currently open structure, and 
C ** restores the open
C ** structure and element pointer from the structure stack.}
C */
       external ptk_closestruct !$PRAGMA C(ptk_closestruct)

       call ptk_closestruct()

       RETURN
       END

       SUBROUTINE ptkf_seteditmode(editmode)
C /*
C ** \parambegin
C ** \param{INTEGER}{editmode}{edit mode}{IN}
C ** \paramend
C ** \blurb{This function stores
C **  the current edit mode on the editmode stack and then sets the edit mode
C ** to given value.}
C */
       INTEGER editmode
       external ptk_seteditmode !$PRAGMA C(ptk_seteditmode)

       call ptk_seteditmode(%val(editmode))

       RETURN
       END

       SUBROUTINE ptkf_unseteditmode()
C /*
C ** \blurb{This function restores the current edit mode from the 
C ** edit mode stack.}
C */
       external ptk_unseteditmode !$PRAGMA C(ptk_unseteditmode)

       call ptk_unseteditmode()

       RETURN
       END

       LOGICAL FUNCTION ptkf_getpickid(stid, elptr, pickid)
C /*
C ** \parambegin
C ** \param{INTEGER}{stid}{structure identifier}{IN}
C ** \param{INTEGER}{elptr}{element pointer value}{IN}
C ** \param{INTEGER}{pickid}{pick identifier}{OUT}
C ** \paramend
C ** \blurb{This function inquires the pick identifier at the element position
C ** specified by \pardesc{elptr} in
C **  structure \pardesc{stid}.
C ** The result of the function is TRUE if the element was a pick
C **  identifier, otherwise FALSE.}
C */
       INTEGER stid, elptr, pickid
       LOGICAL*1 ptk_getpickid, ans
       external ptk_getpickid !$PRAGMA C(ptk_getpickid)

       ans = ptk_getpickid(%val(stid), %val(elptr), pickid)
       if (ans .eq. 1) then
          ptkf_getpickid = .TRUE.
       else
          ptkf_getpickid = .FALSE.
       endif

       RETURN
       END

       LOGICAL FUNCTION ptkf_getexecuteid(stid, elptr, execid)
C /*
C ** \parambegin
C ** \param{INTEGER}{stid}{structure identifier}{IN}
C ** \param{INTEGER}{elptr}{element pointer value}{IN}
C ** \param{INTEGER}{execid}{execute structure identifier}{OUT}
C ** \paramend
C ** \blurb{This function inquires the execute element
C **  identifier at the element position
C ** specified by \pardesc{elptr} in
C **  structure \pardesc{stid}.
C ** The result of the function is TRUE if the element was an execute
C **  element, otherwise FALSE..}
C */
       INTEGER stid, elptr, execid
       LOGICAL*1 ptk_getexecuteid, ans
       external ptk_getexecuteid !$PRAGMA C(ptk_getexecuteid)

       ans = ptk_getexecuteid(%val(stid), %val(elptr), execid)
       if (ans .eq. 1) then
          ptkf_getexecuteid = .TRUE.
       else
          ptkf_getexecuteid = .FALSE.
       endif

       RETURN
       END

       INTEGER FUNCTION ptkf_elemcount(stid)
C /*
C ** \parambegin
C ** \param{INTEGER}{stid}{structure identifier}{IN}
C ** \paramend
C ** \blurb{This functions counts the number of elements 
C ** in  structure \pardesc{stid},
C ** returning  the number of elements, or -1 if the structure does
C ** not exist.}
C */
       INTEGER stid
       external ptk_elemcount !$PRAGMA C(ptk_elemcount)

       ptkf_elemcount = ptk_elemcount(%val(stid))

       RETURN
       END

       LOGICAL FUNCTION ptkf_structexists(stid)
C /*
C ** \parambegin
C ** \param{INTEGER}{stid}{structure identifier}{IN}
C ** \paramend
C ** \blurb{This function checks if structure \pardesc{stid} exists 
C ** in the CSS, returning TRUE if it exists, otherwise FALSE.}
C */
       INTEGER stid
       LOGICAL*1 ptk_structexists, ans
       external ptk_structexists !$PRAGMA C(ptk_structexists)

       ans = ptk_structexists(stid)
       if (ans .eq. 1) then
          ptkf_structexists = .TRUE.
       else
          ptkf_structexists = .FALSE.
       endif

       RETURN
       END

       SUBROUTINE ptkf_getelemtype(elemstr, eltype)
C /*
C ** \parambegin
C ** \param{CHARACTER*(*)}{elemstr}{string giving element type}{IN}
C ** \param{INTEGER}{eltype}{element type}{OUT}
C ** \paramend
C ** \blurb{This function converts the string \pardesc{elemstr}
C ** into its corresponding element type. For example the element type for
C **  "polyline3", would be PEPL3.}
C */
       CHARACTER*(*) elemstr
       INTEGER eltype
       external ptk_getelemtype !$PRAGMA C(ptk_getelemtype)

       call ptk_getelemtype(elemstr, eltype)

       RETURN
       END

       SUBROUTINE ptkf_getelemtypename(eltype, size, elemstr, 
& totalsize)
C /*
C ** \parambegin
C ** \param{INTEGER}{eltype}{element type}{IN}
C ** \param{INTEGER}{size}{size of buffer allocated by application}{IN}
C ** \param{CHARACTER*(*)}{elemstr}{string giving element type}{OUT}
C ** \param{INTEGER}{totalsize}{length of string}{OUT}
C ** \paramend
C ** \blurb{This function converts element type \pardesc{eltype}
C **  into the corresponding character string, which is returned in
C ** \pardesc{elemstr}. For example, the string corresponding to
C ** PEPL3 would be "polyline3".}
C */
       INTEGER eltype, size
       CHARACTER*(*) elemstr
       INTEGER totalsize
       external ptk_getelemtypename !$PRAGMA C(ptk_getelemtypename)

       call ptk_getelemtypename(%val(eltype), %val(size), elemstr, 
& totalsize)

       RETURN
       END

       SUBROUTINE ptkf_copyelem(structid, elemid)
C /*
C ** \parambegin
C ** \param{INTEGER}{structid}{structure identifier}{IN}
C ** \param{INTEGER}{elemid}{element number}{IN}
C ** \paramend
C ** \blurb{This function copies the element at position \pardesc{elemid}
C ** in structure \pardesc{structid}, into the currently
C ** open structure.}
C */
       INTEGER structid, elemid
       external ptk_copyelem !$PRAGMA C(ptk_copyelem)

       call ptk_copyelem(%val(structid), %val(elemid))

       RETURN
       END

       SUBROUTINE ptkf_copyelemrange(stid, elem1, elem2)
C /*
C ** \parambegin
C ** \param{INTEGER}{stid}{structure identifier}{IN}
C ** \param{INTEGER}{elem1}{element pointer}{IN}
C ** \param{INTEGER}{elem2}{element pointer}{IN}
C ** \paramend
C ** \blurb{This function copies the  element range \pardesc{elem1} to
C ** \pardesc{elem2}
C ** in structure \pardesc{stid} into the currently open structure.}
C */
       INTEGER stid, elem1, elem2
       external ptk_copyelemrange !$PRAGMA C(ptk_copyelemrange)

       call ptk_copyelemrange(%val(stid), %val(elem1), %val(elem2))

       RETURN
       END

       SUBROUTINE ptkf_getprimitivetypename(attr, size, attrstr, 
& totalsize)
C /*
C ** \parambegin
C ** \param{INTEGER}{attr}{primitive type}{IN}
C ** \param{INTEGER}{size}{size of buffer allocated by application}{IN}
C ** \param{CHARACTER*(*)}{attrstr}{string giving primitive type}{OUT}
C ** \param{INTEGER}{totalsize}{length of string}{OUT}
C ** \paramend
C ** \blurb{The function converts the  primitive type \pardesc{attr}
C **  to its corresponding character string, which is returned in
C ** \pardesc{artrstr}. For example, PPLATT would give "polyline".}
C */
       INTEGER attr, size
       CHARACTER*(*) attrstr
       INTEGER totalsize
       external ptk_getprimitivetypename 
& !$PRAGMA C(ptk_getprimitivetypename)

       call ptk_getprimitivetypename(%val(attr), %val(size), 
& attrstr, totalsize)

       RETURN
       END

       LOGICAL FUNCTION ptkf_removestruct(stid)
C /*
C ** \parambegin
C ** \param{INTEGER}{stid}{structure identifier}{IN}
C ** \paramend
C ** \blurb{This function deletes structure \pardesc{stid}, 
C ** if it already exists,
C ** returning TRUE if the structure was deleted, otherwise FALSE.}
C */
       INTEGER stid
       LOGICAL*1 ptk_removestruct, ans
       external ptk_removestruct !$PRAGMA C(ptk_removestruct)

       ans = ptk_removestruct(%val(stid))
       if (ans .eq. 1) then
          ptkf_removestruct = .TRUE.
       else
          ptkf_removestruct = .FALSE.
       endif

       RETURN
       END

       SUBROUTINE ptkf_findelemtype(eltypelst, lenlst, srchdir, 
& srchstat, elptr, lstnum)
C /*
C ** \parambegin
C ** \param{INTEGER}{eltypelst(*)}{list of element types}{IN}
C ** \param{INTEGER}{lenlst}{length of element type list}{IN}
C ** \param{INTEGER}{srchdir}{search direction, forwards or backwards}{IN}
C ** \param{INTEGER}{srchstat}{search success or failure}{OUT}
C ** \param{INTEGER}{elptr}{found element pointer}{OUT}
C ** \param{INTEGER}{lstnum}{index of found item in list}{OUT}
C ** \paramend
C ** \blurb{This function searches the currently open
C ** structure, starting at the current element pointer and proceeding in
C **  direction \pardesc{srchdir}, for the first element whose type
C ** matches any of those given in \pardesc{contentlst}.}
C */
       INTEGER eltypelst(*), lenlst, srchdir, srchstat, elptr, lstnum
       external ptk_findelemtype !$PRAGMA C(ptk_findelemtype)

       call ptk_findelemtype(eltypelst, %val(lenlst), %val(srchdir), 
& %val(srchstat), elptr, lstnum)

       RETURN
       END

       LOGICAL FUNCTION ptkf_findnextpickid(stid, srchdir, eltptr, 
& pickid)
C /*
C ** \parambegin
C ** \param{INTEGER}{stid}{structure identifier}{IN}
C ** \param{INTEGER}{srchdir}{search direction}{IN}
C ** \param{INTEGER}{eltptr}{element pointer of pick identifier}{OUT}
C ** \param{INTEGER}{pickid}{pick identifier value}{OUT}
C ** \paramend
C ** \blurb{This function searches structure \pardesc{stid}, starting
C ** at element \pardesc{elptr} and proceeding in direction \pardesc{srchdir},
C ** looking for a pick identifier structure element. The function
C ** returns TRUE if a pick identifier was found, otherwise FALSE.}
C */
       INTEGER stid, srchdir, eltptr, pickid
       LOGICAL*1 ptk_findnextpickid, ans
       external ptk_findnextpickid !$PRAGMA C(ptk_findnextpickid)

       ans = ptk_findnextpickid(%val(stid), %val(srchdir), eltptr, 
& pickid)
       if (ans .eq. 1) then
          ptkf_findnextpickid = .TRUE.
       else
          ptkf_findnextpickid = .FALSE.
       endif

       RETURN
       END

       LOGICAL FUNCTION ptkf_findlabel(label, eltptr)
C /*
C ** \parambegin
C ** \param{INTEGER}{label}{label value}{IN}
C ** \param{INTEGER}{elemptr}{element pointer of label element}{IN/OUT}
C ** \paramend
C ** \blurb{This function searches forwards through the currently open
C ** structure from the current editing position
C ** looking for a label structure element. The function
C ** returns TRUE if {\tt label} was found, otherwise FALSE.}
C */
       INTEGER label, eltptr
       LOGICAL*1 ptk_findlabel, ans
       external ptk_findlabel !$PRAGMA C(ptk_findlabel)

       ans = ptk_findlabel(%val(label), eltptr)
       if (ans .eq. 1) then
          ptkf_findlabel = .TRUE.
       else
          ptkf_findlabel = .FALSE.
       endif

       RETURN
       END

       SUBROUTINE ptkf_delelemtype(stid, lenlst, eltypelst)
C /*
C ** \parambegin
C ** \param{INTEGER}{stid}{structure identifier}{IN}
C ** \param{INTEGER}{lenlst}{length of element type list}{IN}
C ** \param{INTEGER}{eltypelst(*)}{list of element types to delete}{IN}
C ** \paramend
C ** \blurb{This function deletes every element in 
C ** structure \pardesc{stid}, whose
C ** type matches one of the types  in \pardesc{eltypelst}}.
C */
       INTEGER stid, lenlst, eltypelst(*)
       external ptk_delelemtype !$PRAGMA C(ptk_delelemtype)

       call ptk_delelemtype(%val(stid), %val(lenlst), eltypelst)

       RETURN
       END

       SUBROUTINE ptkf_delelem(numelems)
C /*
C ** \parambegin
C ** \param{INTEGER}{numelems}{number of elements to delete}{IN}
C ** \paramend
C ** \blurb{This function deletes the \pardesc{numelems} elements from the
C ** open structure, starting at the element pointer. If \pardesc{numelems} is
C **  0, all elements up to the end of
C ** the structure are deleted.}
C */
       INTEGER numelems
       external ptk_delelem !$PRAGMA C(ptk_delelem)

       call ptk_delelem(%val(numelems))

       RETURN
       END

       INTEGER FUNCTION ptkf_countchildren(stid)
C /*
C ** \parambegin
C ** \param{INTEGER}{stid}{structure identifier}{IN}
C ** \paramend
C ** \blurb{The function returns the number of structures 
C ** executed by structure \pardesc{stid}.
C ** This is the number of direct execute elements in the structure.}
C */
       INTEGER stid
       INTEGER ptk_countchildren
       external ptk_countchildren !$PRAGMA C(ptk_countchildren)

       ptkf_countchildren = ptk_countchildren(%val(stid))

       RETURN
       END

       INTEGER FUNCTION ptkf_countuniqchildren(stid)
C /*
C ** \parambegin
C ** \param{INTEGER}{stid}{structure identifier}{IN}
C ** \paramend
C ** \blurb{This function returns the number of unique children of  structure
C ** \pardesc{stid}. Thus, if a structure executed 
C ** structures A, B and C, it would
C ** have 3 unique children, regardless of how many times each of
C ** A, B and C were executed.}
C */
       INTEGER stid
       INTEGER ptk_countuniqchildren
       external ptk_countuniqchildren !$PRAGMA C(ptk_countuniqchildren)

       ptkf_countuniqchildren = ptk_countuniqchildren(%val(stid))

       RETURN
       END

       SUBROUTINE ptkf_inqstructnetids(root, num, stids, totalnum)
C /*
C ** \parambegin
C ** \param{INTEGER}{root}{structure network identifer}{IN}
C ** \param{INTEGER}{size}{number of integers allocated in integer list}{IN}
C ** \param{INTEGER}{stids(*)}{list of structure identifiers}{OUT}
C ** \param{INTEGER}{totalsize}{actual number of integers in integer list}{OUT}
C ** \paramend
C ** \blurb{This function returns the
C **  list of unique structure identifiers in the structure network whose 
C ** root is \pardesc{root}.} 
C */
       INTEGER root, num, stids(num), totalnum
       external ptkc_inqstructnetids !$PRAGMA C(ptkc_inqstructnetids)

       call ptkc_inqstructnetids(%val(root), %val(num), stids, 
& totalsize)

       RETURN
       END

       SUBROUTINE ptkf_structsummary(fileptr)
C /*
C ** \parambegin
C ** \param{INTEGER}{fileptr}{file pointer}{IN}
C ** \paramend
C ** \blurb{This function outputs a summary of all the structures in the 
C ** CSS to
C ** file \pardesc{fileptr}, which should be an open writeable file.
C ** The structure identifier of each structure is printed, together 
C ** with its hashed string name, if it has one. The format 
C ** of the list is: {\tt \\
C ** \ \ \ \ \ List of structures in the CSS\\
C ** \ \ \ \ \ -----------------------------\\
C ** \ \\
C ** \ \ \ \ \ structure 1 "helicopter"\\
C ** \ \ \ \ \ structure 45 \\
C ** \ \ \ \ \ structure 51 "helicopter"\\
C ** \ \ \ \ \ etc. }
C ** .}
C */
       INTEGER fileptr
       external ptk_structsummary !$PRAGMA C(ptk_structsummary)

       call ptk_structsummary(getfilep(fileptr))

       RETURN
       END

       SUBROUTINE ptkf_setattrasf(numattrs, attrs, asf)
C /*
C ** \parambegin
C ** \param{INTEGER}{numattrs}{length of attribute list}{IN}
C ** \param{INTEGER}{attrs(*)}{attribute list}{IN}
C ** \param{INTEGER}{asf}{aspect source flag}{IN}
C ** \paramend
C ** \blurb{This function inserts a structure element into
C ** the open structure to set the aspect source flags for each of the
C ** \pardesc{numattrs} attributes in the
C **  list \pardesc{attrs}, according to \pardesc{asf}.}
C */
       INTEGER numattrs, attrs(*), asf
       external ptk_setattrasf !$PRAGMA C(ptk_setattrasf)

       call ptk_setattrasf(%val(numattrs), attrs, %val(asf))

       RETURN
       END

       SUBROUTINE ptkf_setallattrasf(asf)
C /*
C ** \parambegin
C ** \param{INTEGER}{asf}{aspect source flag}{IN}
C ** \paramend
C ** \blurb{This function inserts a structure element into
C ** the open structure to set the aspect source flags for all primitive 
C ** attribiutes, according to \pardesc{asf}.}
C */
       INTEGER asf
       external ptk_setallattrasf !$PRAGMA C(ptk_setallattrasf)

       call ptk_setallattrasf(asf)

       RETURN
       END

       SUBROUTINE ptkf_computecharsize(wsid, str, box, font, charht, 
& charexp)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{CHARACTER*(*)}{str}{string}{IN}
C ** \param{REAL}{box(2)}{width and height of box}{IN}
C ** \param{INTEGER}{font}{text font}{IN}
C ** \param{REAL}{charht}{character height}{OUT}
C ** \param{REAL}{charexp}{character expansion}{OUT}
C ** \paramend
C ** \blurb{This function computes the character height and expansion for 
C **  string \pardesc{str}, using font \pardesc{font}, 
C ** in order for it to fit into the rectangle specifed by \pardesc{box}.}
C */
       INTEGER wsid
       CHARACTER*(*) str
       REAL box(2)
       INTEGER font
       REAL charht, charexp
       external ptk_computecharsize !$PRAGMA C(ptk_computecharsize)

       call ptk_computecharsize(%val(wsid), str, box, %val(font), 
& charht, charexp)

       RETURN
       END

       SUBROUTINE ptkf_computecharheight(wsid, str, box, font, charht)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{CHARACTER*(*)}{str}{string}{IN}
C ** \param{REAL}{box(2)}{width and height of box}{IN}
C ** \param{INTEGER}{font}{text font}{IN}
C ** \param{REAL}{charht}{character height}{OUT}
C ** \paramend
C ** \blurb{This function computes the character height for 
C **  string \pardesc{str}, using font \pardesc{font}, 
C ** in order for it to fit into the rectangle specifed by \pardesc{box}.}
C */
       INTEGER wsid
       CHARACTER*(*) str
       REAL box(2)
       INTEGER font
       REAL charht
       external ptk_computecharheight !$PRAGMA C(ptk_computecharheight)

       call ptk_computecharheight(%val(wsid), str, box, %val(font), 
& charht)

       RETURN
       END

       SUBROUTINE ptkf_setstandardviewport(vlimits, vwormt, vwmpmt, 
& vwcplm, xyclpi, bclipi, fclipi)
C /*
C ** \parambegin
C ** \param{REAL}{vlimits(6)}{viewport bounding box}{IN}
C ** \param{REAL}{vwormt(4, 4)}{view orientation matrix}{OUT}
C ** \param{REAL}{vwmpmt(4, 4)}{view mapping matrix}{OUT}
C ** \param{REAL}{vwcplm(6)}{view clipping limits}{OUT}
C ** \param{INTEGER}{xyclpi}{x-y clipping indicator}{OUT}
C ** \param{INTEGER}{bclipi}{back clipping indicator}{OUT}
C ** \param{INTEGER}{fclipi}{front clipping indicator}{OUT}
C ** \paramend
C ** \blurb{For a window of [0,1], this function creates 
C ** a view representation for a viewport of \pardesc{vlimits}.}
C */
       REAL vlimits(6)
       REAL vwormt(4, 4)
       REAL vwmpmt(4, 4)
       REAL vwcplm(6)
       INTEGER xyclpi, bclipi, fclipi
       INTEGER err
       REAL window(4)

       call ptkf_limit(0.0, 1.0, 0.0, 1.0, window)
       call pevmm3(window, vlimits, 0, 0.5, 0.5, 2.0, 1.0, 
& -1.0, 1.0, err, vwmpmt)
       call ptkf_unitmatrix3(vwormt)
       do 10, i=1,6
 10       vwcplm(i) = vlimits(i)
       xyclpi = PCLIP
       bclipi = PCLIP
       fclipi = PCLIP

       RETURN
       END

       SUBROUTINE ptkf_poststruct(wsid, stid, priority)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{stid}{structure identifier}{IN}
C ** \param{REAL}{priority}{priority with which to post structure}{IN}
C ** \paramend
C ** \blurb{This function posts structure \pardesc{stid} to
C ** workstation \pardesc{wsid}, but only if the structure exists.}
C */
       INTEGER wsid, stid
       REAL priority
       REAL*8 dppriority
       external ptk_poststruct !$PRAGMA C(ptk_poststruct)

       dppriority = priority
       call ptk_poststruct(%val(wsid), %val(stid), %val(dppriority))

       RETURN
       END

       SUBROUTINE ptkf_postrelative(ws, structid, relpriority, 
& relstruct, error)
C /*
C ** \parambegin
C ** \param{INTEGER}{ws}{workstation identifier}{IN}
C ** \param{INTEGER}{structid}{structure identifier}{IN}
C ** \param{INTEGER}{relpriority}{relative priority}{IN}
C ** \param{INTEGER}{relstruct}{relative structure identifier}{IN}
C ** \param{INTEGER}{error}{error code}{OUT}
C ** \paramend
C ** \blurb{This function posts structure \pardesc{structid} at a
C **  priority higher or
C ** lower than that of structure \pardesc{relative structure identifier},
C **  according to \pardesc{relative priority}. 
C **  If \pardesc{relative structure identifier} does not exist, 
C ** \pardesc{error} is set to 
C ** 1. Otherwise, its value is 0.}
C */
       INTEGER ws, structid, relpriority, relstruct, error
       external ptk_postrelative !$PRAGMA C(ptk_postrelative)

       call ptk_postrelative(%val(ws), %val(structid), 
& %val(relpriority), %val(relstruct), error)

       RETURN
       END

       SUBROUTINE ptkf_changepostpriority(ws, structid, relpriority, 
& relstruct, error)
C /*
C ** \parambegin
C ** \param{INTEGER}{ws}{workstation identifier}{IN}
C ** \param{INTEGER}{structid}{structure identifier}{IN}
C ** \param{INTEGER}{relpriority}{relative priority}{IN}
C ** \param{INTEGER}{relstruct}{relative structure identifier}{IN}
C ** \param{INTEGER}{error}{error code}{OUT}
C ** \paramend
C ** \blurb{This function changes the priority of structure \pardesc{structid}
C **  to immediately higher or lower than that of \pardesc{relstruct},
C ** according to \pardesc{relpriority}. 
C ** If \pardesc{structid} does not exist, 
C ** \pardesc{error} is set to 
C ** 1. Otherwise, its value is 0.}
C */
       INTEGER ws, structid, relpriority, relstruct, error
       external ptk_changepostpriority 
& !$PRAGMA C(ptk_changepostpriority)

       call ptk_changepostpriority(%val(ws), %val(structid), 
& %val(relpriority), %val(relstruct), error)

       RETURN
       END

       SUBROUTINE ptkf_inqpostpriority(wsid, structid, priority,
& err)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{structid}{structure identifier}{IN}
C ** \param{REAL}{priority}{priority value}{IN}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function returns the priority of posted structure
C ** \pardesc{structid}.
C ** If \pardesc{structid} does not exist, 
C ** \pardesc{error} is set to 
C ** 1. Otherwise, its value is 0.}
C */
       INTEGER wsid, structid
       REAL priority
       INTEGER err
       external ptk_inqpostpriority !$PRAGMA C(ptk_inqpostpriority)

       call ptk_inqpostpriority(%val(wsid), %val(structid),
& priority, err)

       RETURN
       END

       SUBROUTINE ptkf_redrawallstructs(wsid, flag)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{flag}{control flag}{IN}
C ** \paramend
C ** \blurb{This function calls REDRAW ALL STRUCTURES only if the
C ** visual state of the workstation is deferred.}
C */
       INTEGER wsid, flag
       external ptk_redrawallstructs !$PRAGMA C(ptk_redrawallstructs)

       call ptk_redrawallstructs(%val(wsid), %val(flag))

       RETURN
       END

       SUBROUTINE ptkf_drawcolourtable(stid, llim, ulim)
C /*
C ** \parambegin
C ** \param{INTEGER}{stid}{structure identifier}{IN}
C ** \param{INTEGER}{llim}{lower index value of colour table range}{IN}
C ** \param{INTEGER}{ulim}{upper limit of colour table range.}{IN}
C ** \paramend
C ** \blurb{This function draws a rectangular array of boxes representing
C ** the range \pardesc{llim} to \pardesc{ulim} of
C ** the workstation colour table. The boxes are drawn into structure
C ** \pardesc{stid}.}
C */
       INTEGER stid, llim, ulim
       external ptk_drawcolourtable !$PRAGMA C(ptk_drawcolourtable)

       call ptk_drawcolourtable(%val(stid), %val(llim), %val(ulim))

       RETURN
       END

       SUBROUTINE ptkf_copycolourtable(sourcewsid, destwsid)
C /*
C ** \parambegin
C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
C ** \paramend
C ** \blurb{This function copies the colour
C **  table from workstation \pardesc{sourcewsid} to
C **  workstation \pardesc{destwsid}.}
C */
       INTEGER sourcewsid, destwsid
       external ptk_copycolourtable !$PRAGMA C(ptk_copycolourtable)

       call ptk_copycolourtable(%val(sourcewsid), %val(destwsid))

       RETURN
       END

       SUBROUTINE ptkf_copylinetable(sourcewsid, destwsid)
C /*
C ** \parambegin
C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
C ** \paramend
C ** \blurb{This function copies the polyline bundle
C **  table from workstation \pardesc{sourcewsid} to
C **  workstation \pardesc{destwsid}.}
C */
       INTEGER sourcewsid, destwsid
       external ptk_copylinetable !$PRAGMA C(ptk_copylinetable)

       call ptk_copylinetable(%val(sourcewsid), %val(destwsid))

       RETURN
       END

       SUBROUTINE ptkf_copymarkertable(sourcewsid, destwsid)
C /*
C ** \parambegin
C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
C ** \paramend
C ** \blurb{This function copies the polymarker bundle
C **  table from workstation \pardesc{sourcewsid} to
C **  workstation \pardesc{destwsid}.}
C */
       INTEGER sourcewsid, destwsid
       external ptk_copymarkertable !$PRAGMA C(ptk_copymarkertable)

       call ptk_copymarkertable(%val(sourcewsid), %val(destwsid))

       RETURN
       END

       SUBROUTINE ptkf_copytexttable(sourcewsid, destwsid)
C /*
C ** \parambegin
C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
C ** \paramend
C ** \blurb{This function copies the text bundle
C **  table from workstation \pardesc{sourcewsid} to
C **  workstation \pardesc{destwsid}.}
C */
       INTEGER sourcewsid, destwsid
       external ptk_copytexttable !$PRAGMA C(ptk_copytexttable)

       call ptk_copytexttable(%val(sourcewsid), %val(destwsid))

       RETURN
       END

       SUBROUTINE ptkf_copyinttable(sourcewsid, destwsid)
C /*
C ** \parambegin
C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
C ** \paramend
C ** \blurb{This function copies the interior bundle
C **  table from workstation \pardesc{sourcewsid} to
C **  workstation \pardesc{destwsid}.}
C */
       INTEGER sourcewsid, destwsid
       external ptk_copyinttable !$PRAGMA C(ptk_copyinttable)

       call ptk_copyinttable(%val(sourcewsid), %val(destwsid))

       RETURN
       END

       SUBROUTINE ptkf_copyedgetable(sourcewsid, destwsid)
C /*
C ** \parambegin
C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
C ** \paramend
C ** \blurb{This function copies the edge bundle
C **  table from workstation \pardesc{sourcewsid} to
C **  workstation \pardesc{destwsid}.}
C */
       INTEGER sourcewsid, destwsid
       external ptk_copyedgetable !$PRAGMA C(ptk_copyedgetable)

       call ptk_copyedgetable(%val(sourcewsid), %val(destwsid))

       RETURN
       END

       SUBROUTINE ptkf_copypattable(sourcewsid, destwsid)
C /*
C ** \parambegin
C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
C ** \paramend
C ** \blurb{This function copies the view
C **  table from workstation \pardesc{sourcewsid} to
C **  workstation \pardesc{destwsid}.}
C */
       INTEGER sourcewsid, destwsid
       external ptk_copypattable !$PRAGMA C(ptk_copypattable)

       call ptk_copypattable(%val(sourcewsid), %val(destwsid))

       RETURN
       END

       SUBROUTINE ptkf_copyviewtable(sourcewsid, destwsid)
C /*
C ** \parambegin
C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
C ** \paramend
C ** \blurb{This function copies the pattern bundle
C **  table from workstation \pardesc{sourcewsid} to
C **  workstation \pardesc{destwsid}.}
C */
       INTEGER sourcewsid, destwsid
       external ptk_copyviewtable !$PRAGMA C(ptk_copyviewtable)

       call ptk_copyviewtable(%val(sourcewsid), %val(destwsid))

       RETURN
       END

       SUBROUTINE ptkf_copywssttable(sourcewsid, destwsid)
C /*
C ** \parambegin
C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
C ** \paramend
C ** \blurb{This function copies the workstation colour,
C ** polyline bundle, polymarker bundle, interior bundle, edge bundle,
C ** text bundle, pattern bundle and view
C **  tables from workstation \pardesc{sourcewsid} to
C **  workstation \pardesc{destwsid}.}
C */
       INTEGER sourcewsid, destwsid
       external ptk_copywssttable !$PRAGMA C(ptk_copywssttable)

       call ptk_copywssttable(%val(sourcewsid), %val(destwsid))

       RETURN
       END

       SUBROUTINE ptkf_copypostedstruct(sourcewsid, destwsid)
C /*
C ** \parambegin
C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
C ** \paramend
C ** \blurb{This function posts all the structures already posted to
C ** workstation \pardesc{sourcewsid} to  workstation  \pardesc{destwsid}.}
C */
       INTEGER sourcewsid, destwsid
       external ptk_copypostedstruct !$PRAGMA C(ptk_copypostedstruct)

       call ptk_copypostedstruct(%val(sourcewsid), %val(destwsid))

       RETURN
       END

       SUBROUTINE ptkf_copyhilightfilter(sourcewsid, destwsid)
C /*
C ** \parambegin
C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
C ** \paramend
C ** \blurb{This function copies the highlighting filter 
C ** from workstation \pardesc{sourcewsid} to workstation \pardesc{destwsid}.}
C */
       INTEGER sourcewsid, destwsid
       external ptk_copyhilightfilter !$PRAGMA C(ptk_copyhilightfilter)

       call ptk_copyhilightfilter(%val(sourcewsid), %val(destwsid))

       RETURN
       END

       SUBROUTINE ptkf_copyinvisfilter(sourcewsid, destwsid)
C /*
C ** \parambegin
C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
C ** \paramend
C ** \blurb{This function copies the invisibilty filter 
C ** from workstation \pardesc{sourcewsid} to workstation \pardesc{destwsid}.}
C */
       INTEGER sourcewsid, destwsid
       external ptk_copyinvisfilter !$PRAGMA C(ptk_copyinvisfilter)

       call ptk_copyinvisfilter(%val(sourcewsid), %val(destwsid))

       RETURN
       END

       SUBROUTINE ptkf_copyhlhsrmode(sourcewsid, destwsid)
C /*
C ** \parambegin
C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
C ** \paramend
C ** \blurb{This function copies the HLHSR mode
C ** from workstation \pardesc{sourcewsid} to workstation \pardesc{destwsid}.}
C */
       INTEGER sourcewsid, destwsid
       external ptk_copyhlhsrmode !$PRAGMA C(ptk_copyhlhsrmode)

       call ptk_copyhlhsrmode(%val(sourcewsid), %val(destwsid))

       RETURN
       END

       SUBROUTINE ptkf_inqmaxdevicecoords(wsid, maxdevx, maxdevy)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{REAL}{maxdevx}{maximum device coords along x axis}{OUT}
C ** \param{REAL}{maxdevy}{maximum device coords along y axis}{OUT}
C ** \paramend
C ** \blurb{This function returns the the 
C ** maximum device coordinates for $x$ and $y$ for workstation 
C ** \pardesc{wsid}.}
C */
       INTEGER wsid
       REAL maxdevx, maxdevy
       external ptk_inqmaxdevicecoords 
& !$PRAGMA C(ptk_inqmaxdevicecoords)

       call ptk_inqmaxdevicecoords(%val(wsid), maxdevx, maxdevy)

       RETURN
       END

       SUBROUTINE ptkf_inqmaxdevicecoords3(wsid, maxdevx, maxdevy)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{REAL}{maxdevx}{maximum device coords along x axis}{OUT}
C ** \param{REAL}{maxdevy}{maximum device coords along y axis}{OUT}
C ** \param{REAL}{maxdevz}{maximum device coords along z axis}{OUT}
C ** \paramend
C ** \blurb{This function returns the the 
C ** maximum device coordinates for $x$, $y$
C ** and $z$ for workstation \pardesc{wsid}.}
C */
       INTEGER wsid
       REAL maxdevx, maxdevy, maxdevz
       external ptk_inqmaxdevicecoords3 
& !$PRAGMA C(ptk_inqmaxdevicecoords3)

       call ptk_inqmaxdevicecoords3(%val(wsid), maxdevx, maxdevy, 
& maxdevz)

       RETURN
       END

       SUBROUTINE ptkf_arrow(length, width, centre, angle)
C /*
C ** \parambegin
C ** \param{REAL}{length}{length of arrow}{IN}
C ** \param{REAL}{width}{width of arrow}{IN}
C ** \param{REAL}{centre(3)}{centre of arrow}{IN}
C ** \param{REAL}{angle}{rotation of arrow in degrees anti-clockwise about 
C ** arrow pointing along x-axis.}{IN}
C ** \paramend
C ** \blurb{This function draws an arrow with the specified
C ** length \pardesc{length} and \pardesc{width}, rotated through
C **  \pardesc{angle}, centred at \pardesc{centre}.} 
C */
       REAL length, width, centre(3), angle
       REAL*8 dplength, dpwidth, dpangle
       external ptk_arrow !$PRAGMA C(ptk_arrow)

       dplength = length
       dpwidth = width
       dpangle = angle
       call ptk_arrow(%val(dplength), %val(dpwidth), centre, 
& %val(dpangle))

       RETURN
       END

       SUBROUTINE ptkf_grid(stid)
C /*
C ** \parambegin
C ** \param{INTEGER}{stid}{grid structure identifier}{IN}
C ** \paramend
C ** \blurb{This functions draws a grid of lines on [0,1],
C **  into structure \pardesc{stid}. }
C */
       INTEGER stid
       external ptk_grid !$PRAGMA C(ptk_grid)

       call ptk_grid(%val(stid))

       RETURN
       END

       SUBROUTINE ptkf_framebox(boxcentre, boxsize, framesize, 
& boxcolour, edgecolour, tlcolour, brcolour)
C /*
C ** \parambegin
C ** \param{REAL}{boxcentre(3)}{centre of box}{IN}
C ** \param{REAL}{boxsize(2)}{height and width box}{IN}
C ** \param{REAL}{framesize(2)}{height and width of frame}{IN}
C ** \param{INTEGER}{boxcolour}{box interior colour index}{IN}
C ** \param{INTEGER}{edgecolour}{box edge colour index}{IN}
C ** \param{INTEGER}{tlcolour}{frame top-left colour index}{IN}
C ** \param{INTEGER}{brcolour}{frame bottom-right colour index}{IN}
C ** \paramend
C ** \blurb{This function draws a box in the open
C **  structure with a frame to give a 3D
C ** effect.}
C */
       REAL boxcentre(3), boxsize(2), framesize(2)
       INTEGER boxcolour, edgecolour, tlcolour, brcolour
       external ptk_framebox !$PRAGMA C(ptk_framebox)

       call ptk_framebox(boxcentre, boxsize, framesize,
& %val(boxcolour), %val(edgecolour), %val(tlcolour), %val(brcolour))

       RETURN
       END

C end of plib.f 
